;#!/usr/bin/clisp
; A simple tool to analyze domains

;; args: (domainname)

; Read code from src/
(setq CUSTOM:*LOAD-PATHS* (append (list "./src/") CUSTOM:*LOAD-PATHS*))

; First of all, load shop2. That contains various useful functions for
; parsing the formats, which don't need to be re-implemented.
(load "create-corpus-code")

(defun flatten (tree)
	(let ((result '()))
		(labels ((scan (item)
			(if (listp item)
				(map nil #'scan item)
				(push item result))))
		(scan tree))
		(nreverse result)
	)
)

;; function downloaded off the internet, replaces all occurences of a string
(defun replace-all (string part replacement &key (test #'char=))
"Returns a new string in which all the occurences of the part is replaced with replacement."
    (with-output-to-string (out)
      (loop with part-length = (length part)
            for old-pos = 0 then (+ pos part-length)
            for pos = (search part string
                              :start2 old-pos
                              :test test)
            do (write-string string out
                             :start old-pos
                             :end (or pos (length string)))
            when pos do (write-string replacement out)
            while pos)))

(defun normalize (goal)
	(let ((s (format nil "~A" goal)))
		(setf s (replace-all s "!" "action_"))
		(setf s (replace-all s "-" "_dash_"))
	)
)

(defun is-method (method-name)
	(if (not (REGEXP:MATCH '"^!.*$" (format nil "~A" method-name))) T nil)
)

(defun is-hidden (key)
	(let ((k (format nil "~A" key)))
		(if (or (REGEXP:MATCH '"^!_.*$" k) (REGEXP:MATCH '"^!!.*$" k) (REGEXP:MATCH '"^_.*$" k)) T nil)
	)
)

(defparameter recordstyle "style = \"filled\" penwidth = 1 fillcolor = \"white\" fontname = \"Courier New\" shape=\"Mrecord\"")
(defparameter recordlabel        "\"{~A (C=~A) ~A}\"")
(defparameter recordhiddenlabel  "\"{~A (C=~A)}\"")

(defun join-string-list (string-list)
	"Concatenates a list of strings and puts spaces between the elements."
	(format nil "~{~A~^ ~}" string-list)
)

(defun format-alts (method-name)
	(join-string-list (mapcar
		#'(lambda (item)
			(format nil "|~A (~A)" (car item) (cadr item))
		)
		(get-recipe-descs method-name)
	))
)

;; Print methods
(defun print-method (key value)
	(if (not (is-hidden key))
		(if *dotout*
			(format T (format nil "~~A [~A label=~A];~~%" recordstyle recordlabel) (normalize key) key (gethash key *product-hash*) (format-alts key))
			(if *affordances*
				(format T "~A~%" (cadddr (car value)))
				(format T "~A~%" key)
			)
		)
	)
)

;; Print hidden methods
(defun print-hidden-method (key value)
    (format t "")
	(if (is-hidden key)
		(if *dotout*
			(format T (format nil "~~A [~A label=~A];~~%" recordstyle recordhiddenlabel) (normalize key) key (gethash key *product-hash*))
			(if *affordances*
				(format T "~A~%" (cadddr (car value)))
				(format T "~A~%" key)
			)
		)
	)
)

;; Print operators
(defun print-operator (key value)
	(if (not (is-hidden key))
		(if *dotout*
			(format t "~A [label=\"~A\" color=green fontsize=6];~%" (normalize key) key)
			(if *affordances*
				(format T "~A~%" (cadr (car value)))
				(format T "~A~%" key)
			)
		)
	)
)

;; Print hidden operators
(defun print-hidden-operator (key value)
	(if (is-hidden key)
		(if *dotout*
			(format t "~A [label=\"~A\" color=green fontsize=6];~%" (normalize key) key)
			(if *affordances*
				(format T "~A~%" (cadr (car value)))
				(format T "~A~%" key)
			)
		)
	)
)

;; Walk the tree, and find the toplevel goals.
;; Generally, we assume the top level goal to be
;; a hidden method (prefixed by _). This
(defun print-top-level-methods ()
	(mapcar #'(lambda (item)
		(format t "~A [color=red];~%" (normalize item)))
		(remove-duplicates (flatten (traverse-tree-toplevel '_TOP-GOAL '0)))
	)
)

(defun traverse-tree-toplevel (goal depth)
	(if (> depth '20)
		;; Fallback cutoff
		(list nil)
		(if (not (is-hidden goal))
			;; first non-hidden goal is considered toplevel
			(list goal)
			;; other goals
			(mapcar
				#'(lambda (item)
					(traverse-tree-toplevel item (+ depth '1))
				)
				(get-submethods goal)
			)
		)
	)
)

(defun submethods-of (list-of-children)
	(remove-duplicates (flatten
		(mapcar #'(lambda (item)
				(if (is-method item) item nil)
			)
			list-of-children
		)
	))
)

(defun subactions-of (list-of-children)
	(remove-duplicates (flatten
		(mapcar #'(lambda (item)
				(if (not (is-method item)) item nil)
			)
			list-of-children
		)
	))
)

(defun get-submethods (method-name)
	(submethods-of (get-children method-name))
)

(defun get-subactions (method-name)
	(subactions-of (get-children method-name))
)

(defun get-children (method-name)
	(remove-duplicates
		(flatten (get-recipes method-name))
	)
)

(defun get-recipes (method-name)
	(mapcar
		#'(lambda (item) (let ((xitem (cdr (eval (caddr (cddddr item))))))
			(if (eq (car xitem) '!!INOP)
				(list (list nil))
				(mapcar	; this picks the middle item - the task name
					#'(lambda (item2) (cadr item2))
					; This creates lists of tasks for each item
					xitem
				)
			)
		))
		(gethash method-name *methods*)
	)
)

(defun get-recipe-descs (method-name)
	(mapcar
		#'(lambda (item) (let
			((recipes (cdr (eval (caddr (cddddr item)))))
			 (recipename (cadddr (cdr item)))
			 (recipeweight (caddr item))
			)
			(if (eq (car item) '!!INOP)
				(list (list nil))
				(list recipename recipeweight recipes)
			)
		))
		(gethash method-name *methods*)
	)
)

;; Create a dependency tree of goals.
(defun print-deptree ()
	(traverse-tree-deptree '_TOP-GOAL '0)
)

(defun traverse-tree-deptree (goal depth)
	(if (> depth '20)
		;; Fallback cutoff
		(list nil)
		;; depth < 20
		;; first non-hidden goal is considered toplevel
		(let ((children
			(mapcar
				#'(lambda (item)
					;; prevent direct recursion
					(if (eq goal item)
						'recurse
						(traverse-tree-deptree item (+ depth '1))
					)
				)
				(get-children goal)
			)))
			;; pair goal with children
			(if (eq children nil)
				goal
				(append (list goal) (list children))
			)
		)
	)
)

(defun print-dependencies ()
	(let ((deps (remove-duplicates (traverse-tree-pairs '_TOP-GOAL '0))))
		(mapcar #'(lambda (item)
					(format t "~A -> ~A;~%" (normalize (car item)) (normalize (cadr item)))
				)
				deps
		)
		T
	)
)

(defun merge-lists (xlist lists)
	(let ((res (list)))
		(mapcar #'(lambda (item)
					(setf res (append res item))
				)
				lists
		)
		(append xlist res)
	)
)

(defun get-rank (item)
	(let ((rank (list-length (gethash item *methods*))))
			;; If rank is 0, it could be an atomic action
			(if (< rank 1)
				'1
				rank
			)
	)
)

(defun traverse-tree-pairs (goal depth)
	(if (> depth '20)
		;; Fallback cutoff
		nil
		;; depth < 20
		(let ((direct-deps
				; List of dependencies of the current goal
				(mapcar
					#'(lambda (item)
						(list goal item)
					)
					(merge-lists
						(get-submethods goal)
						(if *actions*
							; Also list atomic actions as dependencies
							(list (get-subactions goal))
						)
					)
				))
			 (children-deps
				(mapcar
					#'(lambda (item)
						(if (and
							;; prevent direct recursion
							(not (eq goal item))
							;; do not descend into leaves
							(is-method item))
							(traverse-tree-pairs item (+ depth '1))
						)
					)
					(get-submethods goal)
				))
			)
			;; pair goal with children
			(if (eq children-deps nil)
				direct-deps
				(merge-lists direct-deps children-deps)
			)
		)
	)
)

(defun get-compound-product ()
	(let ((h (make-hash-table)))
		(traverse-tree-product '_TOP-GOAL h '0)
		(setq *hash* h)
	)
)

(defun list-product (l)
	(if (eq l nil)
		'1
		(* (car l) (list-product (cdr l)))
	)
)

(defun list-sum (l)
	(if (eq l nil)
		'0
		(+ (car l) (list-sum (cdr l)))
	)
)

(defun traverse-tree-product (goal hashtab depth)
	(if (> depth '20)
		;; Fallback cutoff
		'1
		;; depth < 20
		(let ((oneh (gethash goal hashtab)))
			(if oneh
				;; We already have this one resolved, just return it
				oneh
				;; Resolve recursively and continue
				(let ((children (get-submethods goal))
					  (recipes (get-recipes goal))
					  (goalalts (list-length (gethash goal *methods*))))
					(if (eq children nil)
						;; No children, return just the number for this node
						(setf (gethash goal hashtab) goalalts)
						;; Yes children. First resolve the children recursively, then construct a graph.
						(setf (gethash goal hashtab)
							(list-sum  (mapcar #'(lambda (item_children)
									(list-product
										(mapcar #'(lambda (item)
											(if (not (eq goal item))
												(traverse-tree-product item hashtab (+ depth '1))
												;; in case of recursion, just put in 1
												'1
											))
											(submethods-of item_children)
										)
									))
									recipes
								)
							)
						)
					)
				)
			)
		)
	)
)

;; Main
(defparameter *condensed* nil)
(defparameter *dotout* T)
(defparameter *actions* T)
(defparameter *methods* T)
(defparameter *toplevel* T)
(defparameter *affordances* nil)
(defparameter *depends* T)
(defparameter *printhidden* T)

(defun analyze-main (input-name)
	(format t "~%")
	(if *actions*
		; list operators
		(let ()
			(if (not *condensed*) (format t "~%Operators:~%"))
			(maphash #'print-operator *operators*)
			(if *printhidden*
				(maphash #'print-hidden-operator *operators*)
			)
			(format t "~%")
		)
	)
	(setq *product-hash* (get-compound-product))
	(if *methods*
		; list methods
		(let ()
			(if (not *condensed*) (format t "~%Methods: ~%"))
			(maphash #'print-method *methods*)
			(if *printhidden*
				(maphash #'print-hidden-method *methods*)
			)
			(if *toplevel*
				(let ()
					(if (not *condensed*) (format t "~%~%Toplevel methods:~%"))
					(print-top-level-methods)
				)
			)
		)
	)
	(if *depends*
		; print dependencies
		(let ()
			(if (not *condensed*) (format t "~%~%Dependencies:~%"))
			(print-dependencies)
		)
	)
)

(defun print-help ()
	(format t "~%~%usage: analyze.lisp [flags] <corpus-name>")
	(format t "~%Flags: (use --noflag for negation)")
	(format t "~% --dotout       - format output for dot files [~A]" *dotout*)
	(format t "~% --condensed    - simplified output [~A]" *condensed*)
	(format t "~%")
	(format t "~% --printhidden  - print hidden methods/actions [~A]" *printhidden*)
	(format t "~% --actions      - print actions [~A]" *actions*)
	(format t "~% --methods      - print methods [~A]" *methods*)
	(format t "~% --toplevel     - print toplevel methods [~A]" *toplevel*)
	(format t "~% --affordances  - print affordances for each method [~A]" *affordances*)
	(format t "~% --depends      - print dependencies between methods [~A]" *depends*)
)

;; get command line args
(if (not (> (length *args*) 0))
	(print-help)
	(let ()
		(loop for i in *args* do
			(cond 
				((string= i "--dotout") (setq *dotout* T))
				((string= i "--nodotout") (setq *dotout* nil))
				((string= i "--condensed") (setq *condensed* T))
				((string= i "--nocondensed") (setq *condensed* nil))
				((string= i "--printhidden") (setq *printhidden* T))
				((string= i "--noprinthidden") (setq *printhidden* nil))
				((string= i "--actions") (setq *actions* T))
				((string= i "--noactions") (setq *actions* nil))
				((string= i "--methods") (setq *methods* T))
				((string= i "--nomethods") (setq *methods* nil))
				((string= i "--toplevel") (setq *toplevel* T))
				((string= i "--notoplevel") (setq *toplevel* nil))
				((string= i "--affordances") (setq *affordances* T))
				((string= i "--noaffordances") (setq *affordances* nil))
				((string= i "--depends") (setq *depends* T))
				((string= i "--nodepends") (setq *depends* nil))
				(T (setq *input-name* i))
			)
		)
		(load (concatenate 'string *input-name* "/plib"))
		(analyze-main *input-name*)
	)
)

